home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / globaldb.lisp < prev    next >
Encoding:
Text File  |  1992-04-03  |  38.0 KB  |  1,157 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: globaldb.lisp,v 1.24 92/04/02 15:32:22 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file provides a functional interface to global information about
  15. ;;; named things in the system.  Information is considered to be global if it
  16. ;;; must persist between invocations of the compiler.  The use of a functional
  17. ;;; interface eliminates the need for the compiler to worry about the actual
  18. ;;; representation.   This is important, since the information may well have
  19. ;;; several representations.   This code also deals with the need for multiple
  20. ;;; "global" environments, so that changing something in the compiler doesn't
  21. ;;; trash the running Lisp environment.
  22. ;;;
  23. ;;;    The database contains arbitrary Lisp values, addressed by a combination
  24. ;;; of Name, Class and Type.  The Name is a EQUAL-thing which is the name of
  25. ;;; the thing we are recording information about.  Class is the kind of object
  26. ;;; involved.  Typical classes are Function, Variable, Type, ...  A Type names
  27. ;;; a particular piece of information within a given class.  Class and Type are
  28. ;;; symbols, but are compared with STRING=.
  29. ;;;
  30. ;;; Written by Rob MacLachlan
  31. ;;;
  32. (in-package "C")
  33. (use-package "EXTENSIONS")
  34. (use-package "SYSTEM")
  35.  
  36. (in-package "EXTENSIONS")
  37. (export '(info clear-info define-info-class define-info-type
  38.            make-info-environment do-info *info-environment*
  39.            compact-info-environment))
  40.  
  41. (in-package "C")
  42.  
  43. ;;; The defvar for this appears later.
  44. (proclaim '(special *universal-type*))
  45. (proclaim '(type list type-specifier-symbols))
  46.  
  47.  
  48. ;;; PRIMIFY  --  Internal
  49. ;;;
  50. ;;;    Given any non-negative integer, return a prime number >= to it.
  51. ;;;
  52. (defun primify (x)
  53.   (declare (type unsigned-byte x))
  54.   (do ((n (logior x 1) (+ n 2)))
  55.       ((system:primep n) n)))
  56.  
  57.  
  58.  
  59. ;;;; Defining info types:
  60.  
  61. (eval-when (compile load eval)
  62.  
  63. (defstruct (class-info
  64.         (:constructor make-class-info (name))
  65.         (:print-function
  66.          (lambda (s stream d)
  67.            (declare (ignore d))
  68.            (format stream "#<Class-Info ~S>" (class-info-name s)))))
  69.   ;;
  70.   ;; String name of this class.
  71.   (name nil :type simple-string)
  72.   ;;
  73.   ;; List of Type-Info structures for each type in this class.
  74.   (types () :type list))
  75.  
  76.  
  77. ;;; At run-time, we represent the type of info that we want by a small
  78. ;;; non-negative integer.
  79. ;;;
  80. (defconstant type-number-bits 6)
  81. (deftype type-number () `(unsigned-byte ,type-number-bits))
  82. ;;;
  83. ;;; Also initialized in GLOBALDB-INIT...
  84. (defvar *type-numbers*
  85.   (make-array (ash 1 type-number-bits)  :initial-element nil))
  86.  
  87.  
  88. (defstruct (type-info
  89.         (:print-function
  90.          (lambda (s stream d)
  91.            (declare (ignore d))
  92.            (format stream "#<Type-Info ~S ~S, Number = ~D>"
  93.                (class-info-name (type-info-class s))
  94.                (type-info-name s)
  95.                (type-info-number s)))))
  96.                  
  97.   ;;
  98.   ;; String name of this type.
  99.   (name (required-argument) :type simple-string)
  100.   ;;
  101.   ;; This type's class.
  102.   (class (required-argument) :type class-info)
  103.   ;;
  104.   ;; A number that uniquely identifies this type (and implicitly its class.)
  105.   (number (required-argument) :type type-number)
  106.   ;;
  107.   ;; Type specifier which info of this type must satisfy.
  108.   (type nil :type t)
  109.   ;;
  110.   ;; Function called when there is no information of this type.
  111.   (default #'(lambda () (error "Type not defined yet.")) :type function))
  112.  
  113.  
  114. ;;; A hashtable from class names to Class-Info structures.  This data structure
  115. ;;; exists at compile time as well as run time.  Also initialized in
  116. ;;; GLOBALDB-INIT...
  117. ;;;
  118. (defvar *info-classes* (make-hash-table :test #'equal))
  119. (proclaim '(hash-table *info-classes*))
  120.  
  121.  
  122. ;;; FIND-TYPE-INFO  --  Internal
  123. ;;;
  124. ;;;    If Name is the name of a type in Class, then return the TYPE-INFO,
  125. ;;; otherwise NIL.
  126. ;;;
  127. (defun find-type-info (name class)
  128.   (declare (simple-string name) (type class-info class))
  129.   (dolist (type (class-info-types class) nil)
  130.     (when (string= (type-info-name type) name)
  131.       (return type))))
  132.  
  133.  
  134. ;;; Class-Info-Or-Lose, Type-Info-Or-Lose --  Internal
  135. ;;;
  136. ;;;    Return the info structure for an info class or type, or die trying.
  137. ;;;
  138. (proclaim '(function class-info-or-lose (string) class-info))
  139. (defun class-info-or-lose (class)
  140.   (or (gethash class *info-classes*)
  141.       (error "~S is not a defined info class." class)))
  142. ;;;
  143. (proclaim '(function type-info-or-lose (string string) type-info))
  144. (defun type-info-or-lose (class type)
  145.   (or (find-type-info type (class-info-or-lose class))
  146.       (error "~S is not a defined info type." type)))
  147.  
  148.  
  149. ;;; Define-Info-Class  --  Public
  150. ;;;
  151. ;;;    Set up the data structures to support an info class.  We make sure that
  152. ;;; the class exists at compile time so that macros can use it, but don't
  153. ;;; actually store the init function until load time so that we don't break the
  154. ;;; running compiler.
  155. ;;;
  156. (defmacro define-info-class (class)
  157.   "Define-Info-Class Class
  158.   Define a new class of global information."
  159.   `(progn
  160.      (eval-when (compile load eval)
  161.        (%define-info-class ',(symbol-name class)))
  162.      ',class))
  163.  
  164.  
  165. ;;; %Define-Info-Class  --  Internal
  166. ;;;
  167. ;;;    If there is no info for the class, then create it, otherwise do nothing.
  168. ;;;
  169. (proclaim '(function %define-info-class (string) void))
  170. (defun %define-info-class (class)
  171.   (unless (gethash class *info-classes*)
  172.     (setf (gethash class *info-classes*) (make-class-info class))))
  173.  
  174.  
  175. ;;; FIND-UNUSED-TYPE-NUMBER  --  Internal
  176. ;;;
  177. ;;;    Find a type number not already in use by looking for a null entry in
  178. ;;; *TYPE-NUMBERS*.
  179. ;;;
  180. (defun find-unused-type-number ()
  181.   (or (position nil *type-numbers*)
  182.       (error "Out of INFO type numbers!")))
  183.  
  184.  
  185. ;;; Define-Info-Type  --  Public
  186. ;;;
  187. ;;;    The main thing we do is determine the type's number.  We need to do this
  188. ;;; at macroexpansion time, since both the COMPILE and LOAD time calls to
  189. ;;; %DEFINE-INFO-TYPE must use the same type number.
  190. ;;;
  191. (defmacro define-info-type (class type type-spec &optional default)
  192.   "Define-Info-Type Class Type default Type-Spec
  193.   Define a new type of global information for Class.  Type is the symbol name
  194.   of the type, Default is the value for that type when it hasn't been set, and
  195.   Type-Spec is a type-specifier which values of the type must satisfy.  The
  196.   default expression is evaluated each time the information is needed, with
  197.   Name bound to the name for which the information is being looked up.  If the
  198.   default evaluates to something with the second value true, then the second
  199.   value of Info will also be true."
  200.   (let* ((class (symbol-name class))
  201.      (type (symbol-name type))
  202.      (old (find-type-info type (class-info-or-lose class))))
  203.     `(progn
  204.        (eval-when (compile load eval)
  205.      (%define-info-type ',class ',type ',type-spec
  206.                 ,(if old
  207.                  (type-info-number old)
  208.                  (find-unused-type-number))))
  209.        (eval-when (load eval)
  210.      (setf (type-info-default (type-info-or-lose ',class ',type))
  211.            #'(lambda (name) name ,default)))
  212.        ',type)))
  213.  
  214.  
  215. ;;; %Define-Info-Type  --  Internal
  216. ;;;
  217. ;;;    If there is no such type, create it.  In any case, set the type
  218. ;;; specifier for the value.  The class must exist.
  219. ;;;
  220. (defun %define-info-type (class type type-spec number)
  221.   (declare (simple-string class type) (type type-number number))
  222.   (let* ((class-info (class-info-or-lose class))
  223.      (old (find-type-info type class-info))
  224.      (res (or old
  225.           (make-type-info :name type
  226.                   :class class-info
  227.                   :number number
  228.                   :type type-spec)))
  229.      (num-old (svref *type-numbers* number)))
  230.     (cond (old
  231.        (setf (type-info-type res) type-spec)
  232.        (unless (= (type-info-number res) number)
  233.          (cerror "Redefine it." "Changing type number for ~A ~A."
  234.              class type)
  235.          (setf (type-info-number res) number)))
  236.       (t
  237.        (push res (class-info-types class-info))))
  238.  
  239.     (unless (eq num-old res)
  240.       (when num-old
  241.     (cerror "Go for it." "Reusing type number for ~A ~A."
  242.         (class-info-name (type-info-class num-old))
  243.         (type-info-name num-old)))
  244.       (setf (svref *type-numbers* number) res)))
  245.  
  246.   (undefined-value))
  247.  
  248. ); eval-when (compile load eval)
  249.  
  250.  
  251. ;;;; Info environments:
  252. ;;;
  253. ;;;    We do info access relative to the current *info-environment*.  This is a
  254. ;;; list of INFO-ENVIRONMENT structures we search.  The variable is actually
  255. ;;; initialized in GLOBALDB-INIT.
  256.  
  257. (defvar *info-environment*)
  258. (proclaim '(type list *info-environment*))
  259.  
  260.  
  261. (defun %print-info-environment (s stream d)
  262.   (declare (ignore d) (stream stream)) 
  263.   (format stream "#<~S ~S>" (type-of s) (info-env-name s)))
  264.  
  265.  
  266. ;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping
  267. ;;; reasons.  If we access with accessors for the exact type, then the inline
  268. ;;; type check will win.  If the inline check didn't win, we would try to use
  269. ;;; the type system before it was properly initialized.
  270. ;;;
  271. (defstruct (info-env (:print-function %print-info-environment))
  272.   ;;
  273.   ;; Some string describing what is in this environment, for printing purposes
  274.   ;; only.
  275.   (name (required-argument) :type string))
  276.  
  277.  
  278. ;;; INFO-HASH  --  Internal
  279. ;;;
  280. ;;;    Semantically equivalent to SXHASH, but optimized for legal function
  281. ;;; names.  Note: semantically equivalent does *not* mean that it always
  282. ;;; returns the same value as SXHASH, just that it satisfies the formal
  283. ;;; definition of SXHASH.
  284. ;;;
  285. ;;;    All we do for now is pick off the cases of a symbol and a list of two
  286. ;;; symbols [e.g. (SETF FOO)].  The symbol case is the same as what SXHASH
  287. ;;; does, but we get there more expeditiously.  With the two-list, we LOGXOR a
  288. ;;; random constant with the hash of the second symbol.
  289. ;;;
  290. (proclaim '(inline info-hash))
  291. (defun info-hash (x)
  292.   (cond
  293.    ((symbolp x)
  294.     (%sxhash-simple-string (symbol-name x)))
  295.    ((and (listp x)
  296.      (eq (car x) 'setf))
  297.     (let ((next (cdr x)))
  298.       (when (listp next)
  299.     (let ((name (car next)))
  300.       (when (and (symbolp name) (null (cdr next)))
  301.         (return-from info-hash
  302.              (logxor (%sxhash-simple-string (symbol-name name))
  303.                  110680597))))))
  304.     (sxhash x))
  305.    (t
  306.     (sxhash x))))
  307.  
  308.  
  309. ;;;; Generic interfaces:
  310.  
  311. ;;; Info  --  Public
  312. ;;;
  313. ;;;    This is a macro so that we can resolve the Class and Type to a type
  314. ;;; number at compile time.  When we check the new-value's type directly in the
  315. ;;; SETF expansion, since the check can be done much more efficiently when the
  316. ;;; type is constant.
  317. ;;;
  318. (defmacro info (class type name)
  319.   "Return the information of the specified Type and Class for Name.
  320.   The second value is true if there is any such information recorded.  If there
  321.   is no information, the first value is the default and the second value is NIL."
  322.   ;;
  323.   ;; ### Should be a values type, but interpreter can't hack that now.
  324.   (let* ((class (symbol-name class))
  325.      (type (symbol-name type))
  326.      (info (type-info-or-lose class type)))
  327.     `(truly-the ,(type-info-type info)
  328.         (get-info-value ,name ,(type-info-number info)))))
  329. ;;;
  330. (define-setf-method info (class type name)
  331.   "Set the global information for Name."
  332.   (let* ((n-name (gensym))
  333.      (n-value (gensym))
  334.      (class-str (symbol-name class))
  335.      (type-str (symbol-name type))
  336.      (info (type-info-or-lose class-str type-str)))
  337.     (values
  338.      `(,n-name)
  339.      `(,name)
  340.      `(,n-value)
  341.      `(progn
  342.     (check-type ,n-value ,(type-info-type info))
  343.     (set-info-value ,n-name ,(type-info-number info) ,n-value))
  344.      `(info ,class ,type ,n-name))))
  345.  
  346.  
  347. ;;; DO-INFO  --  Public
  348. ;;;
  349. (defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
  350.             (type-number (gensym)) (value (gensym)))
  351.            &body body)
  352.   "DO-INFO (Env &Key Name Class Type Value) Form*
  353.   Iterate over all the values stored in the Info-Env Env.  Name is bound to
  354.   the entry's name, Class and Type are bound to the class and type
  355.   (represented as strings), and Value is bound to the entry's value."
  356.   (once-only ((n-env env))
  357.     `(if (typep ,n-env 'volatile-info-env)
  358.      ,(do-volatile-info name class type type-number value n-env body)
  359.      ,(do-compact-info name class type type-number value n-env body))))
  360.  
  361.  
  362. (eval-when (compile load eval)
  363.  
  364. ;;; DO-COMPACT-INFO  --  Internal
  365. ;;;
  366. ;;;    Return code to iterate over a compact info environment.
  367. ;;;
  368. (defun do-compact-info (name-var class-var type-var type-number-var value-var
  369.                  n-env body)
  370.   (let ((n-index (gensym)) (n-type (gensym)) (punt (gensym)))
  371.     (once-only ((n-table `(compact-info-env-table ,n-env))
  372.         (n-entries-index `(compact-info-env-index ,n-env))
  373.         (n-entries `(compact-info-env-entries ,n-env))
  374.         (n-entries-info `(compact-info-env-entries-info ,n-env))
  375.         (n-type-numbers '*type-numbers*))
  376.       `(dotimes (,n-index (length ,n-table))
  377.      (declare (type index ,n-index))
  378.      (block ,PUNT
  379.        (let ((,name-var (svref ,n-table ,n-index)))
  380.          (unless (eql ,name-var 0)
  381.            (do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
  382.                        (1+ ,n-type)))
  383.                  (nil)
  384.          (declare (type index ,n-type))
  385.          ,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
  386.             `(let ((,type-number-var
  387.                 (logand ,n-info compact-info-entry-type-mask)))
  388.                ,(once-only ((n-type-info
  389.                      `(svref ,n-type-numbers
  390.                          ,type-number-var)))
  391.               `(let ((,type-var (type-info-name ,n-type-info))
  392.                  (,class-var (class-info-name
  393.                           (type-info-class ,n-type-info)))
  394.                  (,value-var (svref ,n-entries ,n-type)))
  395.                  (declare (ignorable ,type-var ,class-var
  396.                          ,value-var))
  397.                  ,@body
  398.                  (unless (zerop (logand ,n-info compact-info-entry-last))
  399.                    (return-from ,PUNT))))))))))))))
  400.  
  401. ;;; DO-VOLATILE-INFO  --  Internal
  402. ;;;
  403. ;;;    Return code to iterate over a volatile info environment.
  404. ;;;
  405. (defun do-volatile-info (name-var class-var type-var type-number-var value-var
  406.                   n-env body)
  407.   (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
  408.     (once-only ((n-table `(volatile-info-env-table ,n-env))
  409.         (n-type-numbers '*type-numbers*))
  410.       `(dotimes (,n-index (length ,n-table))
  411.      (do-anonymous ((,n-names (svref ,n-table ,n-index)
  412.                   (cdr ,n-names)))
  413.                ((null ,n-names))
  414.        (let ((,name-var (caar ,n-names)))
  415.          (declare (ignorable ,name-var))
  416.          (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
  417.                ((null ,n-types))
  418.            (let ((,type-number-var (caar ,n-types)))
  419.          ,(once-only ((n-type `(svref ,n-type-numbers
  420.                           ,type-number-var)))
  421.             `(let ((,type-var (type-info-name ,n-type))
  422.                (,class-var (class-info-name
  423.                     (type-info-class ,n-type)))
  424.                (,value-var (cdar ,n-types)))
  425.                (declare (ignorable ,type-var ,class-var ,value-var))
  426.                ,@body))))))))))
  427.  
  428.  
  429. ); Eval-When (Compile Load Eval)
  430.  
  431.  
  432. ;;;; INFO cache:
  433. ;;;
  434. ;;;    We use a hash cache to cache name X type => value for the current value
  435. ;;; of *INFO-ENVIRONMENT*.  This is in addition to the per-environment caching
  436. ;;; of name => types.
  437. ;;;
  438.  
  439. ;;; The value of *INFO-ENVIRONMENT* that has cached values.  *INFO-ENVIRONMENT*
  440. ;;; should nevern be destructively modified, so it is EQ to this, then the
  441. ;;; cache is valid.
  442. ;;;
  443. (defvar *cached-info-environment*)
  444.  
  445.  
  446. ;;; INFO-CACHE-HASH  --  Internal
  447. ;;;
  448. ;;;    Hash function used for INFO cache.
  449. ;;;
  450. (defmacro info-cache-hash (name type)
  451.   `(the fixnum
  452.     (logand
  453.      (the fixnum
  454.           (logxor (the fixnum (cache-hash-eq ,name))
  455.               (the fixnum (ash (the fixnum ,type) 7))))
  456.      #x3FF)))
  457.  
  458.  
  459. (define-hash-cache info ((name eq) (type eq))
  460.   :values 2
  461.   :hash-function info-cache-hash
  462.   :hash-bits 10
  463.   :default (values nil :empty))
  464.  
  465.  
  466. ;;; INFO-CACHE-INIT  --  Internal
  467. ;;;
  468. ;;;    Set up the info cache.  The top-level code of DEFINE-HASH-CACHE can't
  469. ;;; initialize the cache, since it must be initialized before we run any
  470. ;;; top-level forms. This is called in GLOBALDB-INIT.
  471. ;;;
  472. (defun info-cache-init ()
  473.   (setq *cached-info-environment* nil)
  474.   (setq *info-cache-vector* (make-array (* 4 (ash 1 10))))
  475.   (info-cache-clear)
  476.   (undefined-value))
  477.  
  478.  
  479. ;;; Whenever we GC, we must blow away the INFO cache, otherwise values might
  480. ;;; become unreachable (and hence not be updated), and then could become
  481. ;;; reachable again in a future GC.
  482. ;;;
  483. (defun info-cache-gc-hook ()
  484.   (setq *cached-info-environment* nil))
  485. ;;;
  486. (pushnew 'info-cache-gc-hook *after-gc-hooks*)
  487.  
  488.  
  489. ;;; CLEAR-INVALID-INFO-CACHE  --  Internal
  490. ;;;
  491. ;;;    If the info cache is invalid, then clear it.
  492. ;;;
  493. (proclaim '(inline clear-invalid-info-cache))
  494. (defun clear-invalid-info-cache ()
  495.   (unless (eq *info-environment* *cached-info-environment*)
  496.     (without-interrupts
  497.       (info-cache-clear)
  498.       (setq *cached-info-environment* *info-environment*))))
  499.  
  500.  
  501. ;;;; Compact environments:
  502.  
  503. ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
  504. ;;;
  505. (defconstant compact-info-env-entries-bits 16)
  506. (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
  507.  
  508.  
  509. ;;; Type of the values in COMPACT-INFO-ENTRIES-INFO.
  510. ;;;
  511. (deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))
  512.  
  513.  
  514. ;;; This is an open hashtable with rehashing.  Since modification is not
  515. ;;; allowed, we don't have to worry about deleted entries.  We indirect through
  516. ;;; a parallel vector to find the index in the ENTRIES at which the entries for
  517. ;;; a given name starts.
  518. ;;;
  519. (defstruct (compact-info-env
  520.         (:include info-env)
  521.         (:print-function %print-info-environment))
  522.   ;;
  523.   ;; If this value is EQ to the name we want to look up, then the cache hit
  524.   ;; function can be called instead of the lookup function.
  525.   (cache-name 0)
  526.   ;;
  527.   ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no
  528.   ;; entries.
  529.   (cache-index nil :type (or compact-info-entries-index null))
  530.   ;;
  531.   ;; Hashtable of the names in this environment.  If a bucket is unused, it is
  532.   ;; 0.
  533.   (table (required-argument) :type simple-vector)
  534.   ;;
  535.   ;; Indirection vector parallel to TABLE, translating indices in TABLE to the
  536.   ;; start of the ENTRIES for that name.  Unused entries are undefined.
  537.   (index (required-argument)
  538.      :type (simple-array compact-info-entries-index (*)))
  539.   ;;
  540.   ;; Vector contining in contiguous ranges the values of for all the types of
  541.   ;; info for each name.
  542.   (entries (required-argument) :type simple-vector)
  543.   ;;
  544.   ;; Vector parallel to ENTRIES, indicating the type number for the value
  545.   ;; stored in that location and whether this location is the last type of info
  546.   ;; stored for this name.  The type number is in the low TYPE-NUMBER-BITS
  547.   ;; bits, and the next bit is set if this is the last entry.
  548.   (entries-info (required-argument)
  549.         :type (simple-array compact-info-entry (*))))
  550.  
  551.  
  552. (defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
  553. (defconstant compact-info-entry-last (ash 1 type-number-bits))
  554.  
  555.  
  556. ;;; COMPACT-INFO-CACHE-HIT  --  Internal
  557. ;;;
  558. ;;;    Return the value of the type corresponding to Number for the currently
  559. ;;; cached name in Env.
  560. ;;;
  561. (proclaim '(inline compact-info-cache-hit))
  562. (defun compact-info-cache-hit (env number)
  563.   (declare (type compact-info-env env) (type type-number number))
  564.   (let ((entries-info (compact-info-env-entries-info env))
  565.     (index (compact-info-env-cache-index env)))
  566.     (if index
  567.     (do ((index index (1+ index)))
  568.         (nil)
  569.       (declare (type index index))
  570.       (let ((info (aref entries-info index)))
  571.         (when (= (logand info compact-info-entry-type-mask) number)
  572.           (return (values (svref (compact-info-env-entries env) index)
  573.                   t)))
  574.         (unless (zerop (logand compact-info-entry-last info))
  575.           (return (values nil nil)))))
  576.     (values nil nil))))
  577.  
  578.  
  579. ;;; COMPACT-INFO-LOOKUP  --  Internal
  580. ;;;
  581. ;;;    Encache Name in the compact environment Env.  Hash is the INFO-HASH of
  582. ;;; Name.
  583. ;;;
  584. (defun compact-info-lookup (env name hash)
  585.   (declare (type compact-info-env env) (type index hash))
  586.   (let* ((table (compact-info-env-table env))
  587.      (len (length table))
  588.      (len-2 (- len 2))
  589.      (hash2 (- len-2 (rem hash len-2))))
  590.     (declare (type index len-2 hash2))
  591.     (macrolet ((lookup (test)
  592.          `(do ((probe (rem hash len)
  593.                   (let ((new (+ probe hash2)))
  594.                 (declare (type index new))
  595.                 ;;
  596.                 ;; same as (mod new len), but faster.
  597.                 (if (>= new len)
  598.                     (the index (- new len))
  599.                     new))))
  600.               (nil)
  601.             (let ((entry (svref table probe)))
  602.               (when (eql entry 0)
  603.             (return nil))
  604.               (when (,test entry name)
  605.             (return (aref (compact-info-env-index env)
  606.                       probe)))))))
  607.       (setf (compact-info-env-cache-index env)
  608.         (if (symbolp name)
  609.         (lookup eq)
  610.         (lookup equal)))
  611.       (setf (compact-info-env-cache-name env) name)))
  612.  
  613.   (undefined-value))
  614.  
  615.  
  616. ;;; Exact density (modulo rounding) of the hashtable in a compact info
  617. ;;; environment in names/bucket.
  618. ;;;
  619. (defconstant compact-info-environment-density 65)
  620.  
  621.  
  622. ;;; COMPACT-INFO-ENVIRONMENT  --  Public
  623. ;;;
  624. ;;;    Iterate over the environment once to find out how many names and entries
  625. ;;; it has, then build the result.  This code assumes that all the entries for
  626. ;;; a name well be iterated over contiguously, which holds true for the
  627. ;;; implementation of iteration over both kinds of environments.
  628. ;;;
  629. ;;;    When building the table, we sort the entries by POINTER< in an attempt
  630. ;;; to preserve any VM locality present in the original load order, rather than
  631. ;;; randomizing with the original hash function.
  632. ;;; 
  633. (defun compact-info-environment (env &key (name (info-env-name env)))
  634.   "Return a new compact info environment that holds the same information as
  635.   Env."
  636.   (let ((name-count 0)
  637.     (prev-name 0)
  638.     (entry-count 0))
  639.     (collect ((names))
  640.       (let ((types ()))
  641.     (do-info (env :name name :type-number num :value value)
  642.       (unless (eq name prev-name)
  643.         (incf name-count)
  644.         (unless (eql prev-name 0)
  645.           (names (cons prev-name types)))
  646.         (setq prev-name name)
  647.         (setq types ()))
  648.       (incf entry-count)
  649.       (push (cons num value) types))
  650.     (unless (eql prev-name 0)
  651.       (names (cons prev-name types))))
  652.       
  653.       (let* ((table-size
  654.           (primify
  655.            (+ (truncate (* name-count 100)
  656.                 compact-info-environment-density)
  657.           3)))
  658.          (table (make-array table-size :initial-element 0))
  659.          (index (make-array table-size
  660.                 :element-type 'compact-info-entries-index))
  661.          (entries (make-array entry-count))
  662.          (entries-info (make-array entry-count
  663.                        :element-type 'compact-info-entry))
  664.          (sorted (sort (names) #'(lambda (x y)
  665.                        (< (%primitive make-fixnum x)
  666.                       (%primitive make-fixnum y))))))
  667.     (let ((entries-idx 0))
  668.       (dolist (types sorted)
  669.         (let* ((name (first types))
  670.            (hash (info-hash name))
  671.            (len-2 (- table-size 2))
  672.            (hash2 (- len-2 (rem hash len-2))))
  673.           (do ((probe (rem hash table-size)
  674.               (rem (+ probe hash2) table-size)))
  675.           (nil)
  676.         (let ((entry (svref table probe)))
  677.           (when (eql entry 0)
  678.             (setf (svref table probe) name)
  679.             (setf (aref index probe) entries-idx)
  680.             (return))
  681.           (assert (not (equal entry name))))))
  682.  
  683.         (unless (zerop entries-idx)
  684.           (setf (aref entries-info (1- entries-idx)) 
  685.             (logior (aref entries-info (1- entries-idx))
  686.                 compact-info-entry-last)))
  687.  
  688.         (loop for (num . value) in (rest types) do
  689.           (setf (aref entries-info entries-idx) num)
  690.           (setf (aref entries entries-idx) value)
  691.           (incf entries-idx)))
  692.       
  693.       (unless (zerop entry-count)
  694.         (setf (aref entries-info (1- entry-count)) 
  695.           (logior (aref entries-info (1- entry-count))
  696.               compact-info-entry-last)))
  697.       
  698.       (make-compact-info-env :name name
  699.                  :table table
  700.                  :index index
  701.                  :entries entries
  702.                  :entries-info entries-info))))))
  703.       
  704.       
  705.  
  706. ;;;; Volatile environments:
  707.  
  708. ;;; This is a closed hashtable, with the bucket being computed by taking the
  709. ;;; INFO-HASH of the Name mod the table size.
  710. ;;;
  711. (defstruct (volatile-info-env
  712.         (:include info-env)
  713.         (:print-function %print-info-environment))
  714.  
  715.   ;;
  716.   ;; If this value is EQ to the name we want to look up, then the cache hit
  717.   ;; function can be called instead of the lookup function.
  718.   (cache-name 0)
  719.   ;;
  720.   ;; The alist translating type numbers to values for the currently cached
  721.   ;; name.
  722.   (cache-types nil :type list)
  723.   ;;
  724.   ;; Vector of alists of alists of the form:
  725.   ;;    ((Name . ((Type-Number . Value) ...) ...)
  726.   ;;
  727.   (table (required-argument) :type simple-vector)
  728.   ;;
  729.   ;; The number of distinct names currently in this table (each name may have
  730.   ;; multiple entries, since there can be many types of info.
  731.   (count 0 :type index)
  732.   ;;
  733.   ;; The number of names at which we should grow the table and rehash.
  734.   (threshold 0 :type index))
  735.  
  736.  
  737. ;;; VOLATILE-INFO-CACHE-HIT  --  Internal
  738. ;;;
  739. ;;;    Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
  740. ;;;
  741. (proclaim '(inline volatile-info-cache-hit))
  742. (defun volatile-info-cache-hit (env number)
  743.   (declare (type volatile-info-env env) (type type-number number))
  744.   (dolist (type (volatile-info-env-cache-types env) (values nil nil))
  745.     (when (eql (car type) number)
  746.       (return (values (cdr type) t)))))  
  747.  
  748.  
  749. ;;; VOLATILE-INFO-LOOKUP  --  Internal
  750. ;;;
  751. ;;;    Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
  752. ;;;
  753. (defun volatile-info-lookup (env name hash)
  754.   (declare (type volatile-info-env env) (type index hash))
  755.   (let ((table (volatile-info-env-table env)))
  756.     (macrolet ((lookup (test)
  757.          `(dolist (entry (svref table (mod hash (length table))) ())
  758.             (when (,test (car entry) name)
  759.               (return (cdr entry))))))
  760.       (setf (volatile-info-env-cache-types env)
  761.         (if (symbolp name)
  762.         (lookup eq)
  763.         (lookup equal)))
  764.       (setf (volatile-info-env-cache-name env) name)))
  765.  
  766.   (undefined-value))
  767.  
  768.  
  769. ;;; WITH-INFO-BUCKET  --  Internal
  770. ;;;
  771. ;;;    Given a volatile environment Env, bind Table-Var the environment's table
  772. ;;; and Index-Var to the index of Name's bucket in the table.  We also flush
  773. ;;; the cache so that things will be consistent if body modifies something.
  774. ;;;
  775. (eval-when (compile eval)
  776.   (defmacro with-info-bucket ((table-var index-var name env) &body body)
  777.     (once-only ((n-name name)
  778.         (n-env env))
  779.       `(progn
  780.      (setf (volatile-info-env-cache-name ,n-env) 0)
  781.      (let* ((,table-var (volatile-info-env-table ,n-env))
  782.         (,index-var (mod (info-hash ,n-name) (length ,table-var))))
  783.        ,@body)))))
  784.  
  785.  
  786. ;;; GET-WRITE-INFO-ENV  --  Internal
  787. ;;;
  788. ;;;    Get the info environment that we use for write/modification operations.
  789. ;;; This is always the first environment in the list, and must be a
  790. ;;; VOLATILE-INFO-ENV.
  791. ;;;
  792. (proclaim '(inline get-write-info-env))
  793. (defun get-write-info-env ()
  794.   (let ((env (car *info-environment*)))
  795.     (unless env
  796.       (error "No info environment?"))
  797.     (unless (typep env 'volatile-info-env)
  798.       (error "Cannot modify this environment: ~S." env))
  799.     (the volatile-info-env env)))
  800.  
  801.  
  802. ;;; SET-INFO-VALUE  --  Internal
  803. ;;;
  804. ;;;    If Name is already present in the table, then just create or modify the
  805. ;;; specified type.  Otherwise, add the new name and type, checking for
  806. ;;; rehashing.
  807. ;;;
  808. ;;;    We rehash by making a new larger environment, copying all of the entries
  809. ;;; into it, then clobbering the old environment with the new environment's
  810. ;;; table.  We clear the old table to prevent it from holding onto garbage if
  811. ;;; it is statically allocated.
  812. ;;;
  813. (defun set-info-value (name type new-value &optional
  814.                 (env (get-write-info-env)))
  815.   (declare (type type-number type) (type volatile-info-env env)
  816.        (inline assoc))
  817.   (when (eql name 0)
  818.     (error "0 is not a legal INFO name."))
  819.   (clear-invalid-info-cache)
  820.   (info-cache-enter name type new-value t)
  821.   (with-info-bucket (table index name env)
  822.     (let ((types (if (symbolp name)
  823.              (assoc name (svref table index) :test #'eq)
  824.              (assoc name (svref table index) :test #'equal))))
  825.       (cond
  826.        (types
  827.     (let ((value (assoc type (cdr types))))
  828.       (if value
  829.           (setf (cdr value) new-value)
  830.           (push (cons type new-value) (cdr types)))))
  831.        (t
  832.     (push (cons name (list (cons type new-value)))
  833.           (svref table index))
  834.  
  835.     (let ((count (incf (volatile-info-env-count env))))
  836.       (when (>= count (volatile-info-env-threshold env))
  837.         (let ((new (make-info-environment :size (* count 2))))
  838.           (do-info (env :name entry-name :type-number entry-num
  839.                 :value entry-val)
  840.         (set-info-value entry-name entry-num entry-val new))
  841.           (fill (volatile-info-env-table env) nil)
  842.           (setf (volatile-info-env-table env)
  843.             (volatile-info-env-table new))
  844.           (setf (volatile-info-env-threshold env)
  845.             (volatile-info-env-threshold new)))))))))
  846.       
  847.   new-value)
  848.  
  849.  
  850. ;;; The maximum density of the hashtable in a volatile env (in names/bucket).
  851. ;;;
  852. (defconstant volatile-info-environment-density 50)
  853.  
  854.  
  855. ;;; MAKE-INFO-ENVIRONMENT  --  Public
  856. ;;;
  857. ;;;    Make a new volatile environment of the specified size.
  858. ;;;
  859. (defun make-info-environment (&key (size 42) (name "Unknown"))
  860.   (declare (type (integer 1) size))
  861.   (let ((table-size
  862.      (primify (truncate (* size 100) volatile-info-environment-density))))
  863.     (make-volatile-info-env
  864.      :name name
  865.      :table (make-array table-size :initial-element nil)
  866.      :threshold size)))
  867.  
  868.  
  869. ;;; CLEAR-INFO  --  Public
  870. ;;;
  871. (defmacro clear-info (class type name)
  872.   "Clear the information of the the specified Type and Class for Name in the
  873.   current environment, allowing any inherited info to become visible.  We
  874.   return true if there was any info."
  875.   (let* ((class (symbol-name class))
  876.      (type (symbol-name type))
  877.      (info (type-info-or-lose class type)))
  878.     `(clear-info-value ,name ,(type-info-number info))))
  879. ;;;
  880. (defun clear-info-value (name type)
  881.   (declare (type type-number type) (inline assoc))
  882.   (clear-invalid-info-cache)
  883.   (info-cache-enter name type nil :empty)
  884.   (with-info-bucket (table index name (get-write-info-env))
  885.     (let ((types (assoc name (svref table index) :test #'equal)))
  886.       (when (and types
  887.          (assoc type (cdr types)))
  888.     (setf (cdr types)
  889.           (delete type (cdr types) :key #'car))
  890.     t))))
  891.  
  892.  
  893. ;;;; GET-INFO-VALUE:
  894.  
  895. (eval-when (compile eval)
  896.  
  897. ;;; GET-INFO-VALUE-SEARCH  --  Internal
  898. ;;;
  899. ;;;    Return the value from the first environment which has it defined, or
  900. ;;; return the default if none does.  We have a cache for the last name looked
  901. ;;; up in each environment.  We don't compute the hash until the first time the
  902. ;;; cache misses.  When the cache does miss, we invalidate it before calling
  903. ;;; the lookup routine to eliminate the possiblity of the cache being
  904. ;;; partially updated if the lookup is interrupted.
  905. ;;;
  906. (defmacro get-info-value-search ()
  907.   '(let ((hash nil))
  908.      (dolist (env *info-environment*
  909.           (multiple-value-bind
  910.               (val winp)
  911.               (funcall (type-info-default (svref *type-numbers* type))
  912.                    name)
  913.             (values val winp)))
  914.        (macrolet ((frob (lookup cache slot)
  915.             `(progn
  916.                (unless (eq name (,slot env))
  917.              (unless hash
  918.                (setq hash (info-hash name)))
  919.              (setf (,slot env) 0)
  920.              (,lookup env name hash))
  921.                (multiple-value-bind
  922.                (value winp)
  923.                (,cache env type)
  924.              (when winp (return (values value t)))))))
  925.      (if (typep env 'volatile-info-env)
  926.          (frob volatile-info-lookup volatile-info-cache-hit
  927.            volatile-info-env-cache-name)
  928.          (frob compact-info-lookup compact-info-cache-hit
  929.            compact-info-env-cache-name))))))
  930.  
  931. ); Eval-When (Compile Eval)
  932.  
  933.  
  934. ;;; GET-INFO-VALUE  --  Internal
  935. ;;;
  936. ;;;    Check if the name and type is in our cache, if so return it.  Otherwise,
  937. ;;; search for the value and encache it.
  938. ;;;
  939. (defun get-info-value (name type)
  940.   (declare (type type-number type))
  941.   (clear-invalid-info-cache)
  942.   (multiple-value-bind (val winp)
  943.                (info-cache-lookup name type)
  944.     (if (eq winp :empty)
  945.     (multiple-value-bind (val winp)
  946.                  (get-info-value-search)
  947.       (info-cache-enter name type val winp)
  948.       (values val winp))
  949.     (values val winp))))
  950.  
  951.  
  952. ;;;; Initialization:
  953.  
  954. ;;; GLOBALDB-INIT  --  Interface
  955. ;;;
  956. ;;;    Since the global enviornment database is used by top-level forms in this
  957. ;;; file, we must initialize the database before processing any top-level
  958. ;;; forms.  This requires a special initialization function that is called from
  959. ;;; %INITIAL-FUNCTION.  We replicate the init forms of the variables that
  960. ;;; maintain the class/type namespace.  We also initialize the info cache.
  961. ;;;
  962. (defun globaldb-init ()
  963.   (unless (boundp '*info-environment*)
  964.     (setq *info-environment*
  965.       (list (make-info-environment :name "Initial Global"))))
  966.   (unless (boundp '*info-classes*)
  967.     (setq *info-classes* (make-hash-table :test #'equal))
  968.     (setq *type-numbers*
  969.       (make-array (ash 1 type-number-bits)  :initial-element nil)))
  970.  
  971.   (info-cache-init)
  972.   (function-info-init)
  973.   (other-info-init))
  974.  
  975.  
  976. ;;;; Definitions for function information.
  977.  
  978. (defun function-info-init ()
  979.  
  980. (define-info-class function)
  981.  
  982. ;;; The kind of functional object being described.  If null, Name isn't a known
  983. ;;; functional object.
  984. (define-info-type function kind (member nil :function :macro :special-form)
  985.   (if (fboundp name) :function nil))
  986.  
  987. ;;; The type specifier for this function.
  988. (define-info-type function type ctype
  989.   (if (fboundp name)
  990.       (let ((def (fdefinition name)))
  991.     (if (eval:interpreted-function-p def)
  992.         (eval:interpreted-function-type def)
  993.         (specifier-type (%primitive function-type
  994.                     (%primitive closure-function def)))))
  995.       (specifier-type 'function)))
  996.  
  997. ;;; The Assumed-Type for this function, if we have to infer the type due to not
  998. ;;; having a declaration or definition.
  999. (define-info-type function assumed-type (or approximate-function-type null))
  1000.  
  1001. ;;; Where this information came from:
  1002. ;;;  :declared, from a declaration.
  1003. ;;;  :assumed, from uses of the object.
  1004. ;;;  :defined, from examination of the definition.
  1005. (define-info-type function where-from (member :declared :assumed :defined)
  1006.   (if (fboundp name) :defined :assumed))
  1007.  
  1008. ;;; Lambda used for inline expansion of this function.
  1009. (define-info-type function inline-expansion list)
  1010.  
  1011. ;;; Specifies whether this function may be expanded inline.  If null, we
  1012. ;;; don't care.
  1013. (define-info-type function inlinep inlinep nil)
  1014.  
  1015. ;;; A macro-like function which transforms a call to this function into some
  1016. ;;; other Lisp form.  This expansion is inhibited if inline expansion is
  1017. ;;; inhibited.
  1018. (define-info-type function source-transform (or function null))
  1019.  
  1020. ;;; The macroexpansion function for this macro.
  1021. (define-info-type function macro-function (or function null)
  1022.   nil)
  1023.  
  1024. ;;; The compiler-macroexpansion function for this macro.
  1025. (define-info-type function compiler-macro-function (or function null)
  1026.   nil)
  1027.  
  1028. ;;; A function which converts this special form into IR1.
  1029. (define-info-type function ir1-convert (or function null))
  1030.  
  1031. ;;; A function which gets a chance to do stuff to the IR1 for any call to this
  1032. ;;; function.
  1033. (define-info-type function ir1-transform (or function null))
  1034.  
  1035. ;;; If a function is a defstruct slot accessor or setter, then this is the
  1036. ;;; defstruct-definition for the structure that it belongs to.
  1037. (define-info-type function accessor-for (or defstruct-description null)
  1038.   nil)
  1039.  
  1040. ;;; If a function is "known" to the compiler, then this is FUNCTION-INFO
  1041. ;;; structure containing the info used to special-case compilation.
  1042. (define-info-type function info (or function-info null) nil)
  1043.  
  1044. (define-info-type function documentation (or string null) nil)
  1045.  
  1046. (define-info-type function definition t nil)
  1047.  
  1048.  
  1049. ); defun function-info-init
  1050.  
  1051. #|
  1052.   Other:
  1053.     Documentation?
  1054. |#
  1055.  
  1056. ;;;; Definitions for other random information.
  1057.  
  1058. (defun other-info-init ()
  1059.  
  1060. (define-info-class variable)
  1061.  
  1062. ;;; The kind of variable-like thing described.
  1063. (define-info-type variable kind (member :special :constant :global :alien)
  1064.   (if (or (eq (symbol-package name) (symbol-package :end))
  1065.       (member name '(t nil)))
  1066.       :constant
  1067.       :global))
  1068.  
  1069. ;;; The declared type for this variable.
  1070. (define-info-type variable type ctype *universal-type*)
  1071.  
  1072. ;;; Where this type and kind information came from.
  1073. (define-info-type variable where-from (member :declared :assumed :defined)
  1074.   :assumed)
  1075.  
  1076. ;;; The the lisp object which is the value of this constant, if known.
  1077. (define-info-type variable constant-value t
  1078.   (if (boundp name)
  1079.       (values (symbol-value name) t)
  1080.       (values nil nil)))
  1081.  
  1082. (define-info-type variable alien-info (or heap-alien-info null) nil)
  1083.  
  1084. (define-info-type variable documentation (or string null) nil)
  1085.  
  1086. (define-info-class type)
  1087.  
  1088. ;;; The kind of type described.  We return :Structure for standard types that
  1089. ;;; are implemented as structures.
  1090. ;;;
  1091. (define-info-type type kind (member :primitive :defined :structure nil)
  1092.   (if (or (info type builtin name)
  1093.       (info type translator name))
  1094.       :primitive
  1095.       nil))
  1096.  
  1097. ;;; Expander function for a defined type.
  1098. (define-info-type type expander (or function null) nil)
  1099.  
  1100. ;;; Print function for a type.
  1101. (define-info-type type printer (or function symbol null) nil)
  1102.  
  1103. ;;; Make-load-form function for a type.
  1104. (define-info-type type load-form-maker (or function symbol null) nil)
  1105.  
  1106. ;;; Defstruct description information for a structure type.  DEFINED is the
  1107. ;;; current global definition, and is not shadowed by compilation of
  1108. ;;; structure definitions.
  1109. ;;;
  1110. (define-info-type type structure-info (or defstruct-description null) nil)
  1111. (define-info-type type defined-structure-info (or defstruct-description null)
  1112.   nil)
  1113.  
  1114. ;;; True if this type has been frozen with the FREEZE-TYPE declaration.  Only
  1115. ;;; interesting for structure types.
  1116. ;;;
  1117. (define-info-type type frozen boolean nil)
  1118.  
  1119. (define-info-type type documentation (or string null))
  1120.  
  1121. ;;; Function that parses type specifiers into CTYPE structures.
  1122. ;;;
  1123. (define-info-type type translator (or function null) nil)
  1124.  
  1125. ;;; If true, then the type coresponding to this name.
  1126. ;;;
  1127. (define-info-type type builtin (or ctype null) nil)
  1128.  
  1129.  
  1130. (define-info-class declaration)
  1131. (define-info-type declaration recognized boolean)
  1132.  
  1133. (define-info-class alien-type)
  1134. (define-info-type alien-type kind (member :primitive :defined :unknown)
  1135.   :unknown)
  1136. (define-info-type alien-type translator (or function null) nil)
  1137. (define-info-type alien-type definition (or alien-type null) nil)
  1138. (define-info-type alien-type struct (or alien-type null) nil)
  1139. (define-info-type alien-type union (or alien-type null) nil)
  1140. (define-info-type alien-type enum (or alien-type null) nil)
  1141.  
  1142. (define-info-class setf)
  1143.  
  1144. (define-info-type setf inverse (or symbol null) nil)
  1145.  
  1146. (define-info-type setf documentation (or string null) nil)
  1147.  
  1148. (define-info-type setf expander (or function null) nil)
  1149.  
  1150. ;;; Used for storing random documentation types.  The stuff is an alist
  1151. ;;; translating documentation kinds to values.
  1152. ;;;
  1153. (define-info-class random-documentation)
  1154. (define-info-type random-documentation stuff list ())
  1155.  
  1156. ); defun other-info-init
  1157.